#!/usr/bin/perl
#
# Check emails from the users DB and set the
# status field of the user record.
#
# Possible values:
# - blank: No check performed
# - ok: This program checked it
# - bounce: An email bounce message detected
# - tempfail: Temporary failure
# - bad: Definitely not an email
#

use English;
use FileTable;
use POSIX;
use IsEmail qw(isemail $notemailbecause);

# List of permanent error codes.
# Note that these are strings from the check_mail_addr program!

%permerrs = (
"no such host" => 1,
"expected '\@' after local-part" => 1,
"SMTP reports invalid recipient addr" => 1,
"incomplete domain name" => 1, # means "no dot in domain"
"missing '\@domain'" => 1,
	     );

#----------- RUNTIME PARAMETERS ------------
# these ought to be -x options
# Only want to worry about this many persons at a time
# Email checking is SLOW!
$maxerr = 50;
$maxcheck = 200;
$wantstate = ""; # may be bad, tempfail, ok or blank
$| = 1; # immediate output on stdout
#-------------------------------------------
$usage = "$0 [-state state] [-maxcheck n] [-maxerr n]\n";
while ($ARGV[0] =~ /^-/) {
    $opt = shift;
    if ($opt eq "-state") {
	$wantstate = shift;
    } elsif ($opt eq "-maxcheck") {
	$maxcheck = shift() + 0;
    } elsif ($opt eq "-maxerr") {
	$maxerr = shift() + 0;
    } else {
	die $usage;
    }
}
warn "Checking $maxcheck records in state ",
    $wantstate?$wantstate:"<blank>", "\n";
warn "Stopping after $maxerr errors\n";

$starttime = time;

$ckadr = "$ENV{HOME}/bin/check_mail_addr";
$users = FileTable::open("db/users", O_RDWR)
               || die "Unable to open users DB\n";
@candidates = $users->select("state = '$wantstate' limit $maxcheck");
warn "$#candidates selected\n";
#while ($id = $users->each) {
#    # It seems that we always loop when we start writing back.
#    # First identify candidates, then check them.
#    if ($seen{$id}) {
#	warn "Exit - loop detected on id $id\n";
#	last;
#    }
#    $seen{$id} = 1;
#    $user = $users->get($id);
#    if (!$user) {
#	warn "$id: in index but fetch userrec failed\n";
#	count("No record");
#	next;
#    }
#    ++ $reccount;
#    if ($user->{state} ne $wantstate) {
#	count("Skip: State " . $user->{state});
#	next;
#    }
#    push(@candidates, $id);
#    last if $count >= $maxcheck;
#    ++ $count;
#}
#warn "$count candidates selected from $reccount records\n";

$checkstart = time;
# The candidates come out in "random" order, but mostly the same.
# This means that we start out checking just tempfails.
# To get a more randomized order, sort them :-)
for $user (@candidates) {
    $email = $user->{email};
    ++ $checkcount;
    if (!$email) {
	$user->{state} = "bad";
	$user->store;
	count("bad: No email");
	next;
    }
    # With the long distance Email check, this takes so much time
    # that it makes sense to output a dot for every checked record...
    if ($count % 1 == 0 && -t STDERR) {
	warn ".";
    }
    if ($use_ckadr) {
	$mcheck = `$ckadr "$email"`;
	if (($signal = ($CHILD_ERROR & 0xFF)) != 0) {
	    # Child killed - treat as temporary failure
	    $mcheck = "Child killed on signal $signal";
	} elsif ($CHILD_ERROR >> 8 == 0) {
	    count("OK");
	    $user->{state} = "ok";
	    $user->store;
	    next;
	}
	chop $mcheck;
	print "$id\t$mcheck\t\t\t$email\n";
	# Have to make decision on what to do on various states.
	# For now, set temp failure
	if ($permerrs{$mcheck}) {
	    $newstate = "bad";
	} else {
	    $newstate = "tempfail";
	}
    } else {
	if (isemail($email)) {
	    # Don't write anything - not definitive - but skip
	    next;
	} else {
	    warn "Isemail set $notemailbecause - tempfail\n";
	    $newstate = "tempfail";
	}
    }
    ++ $errcount;
    if ($newstate eq $user->{state}) {
	count("still $newstate: $mcheck");
    } else {
	count("$newstate: $mcheck");
	$user->{state} = $newstate;
	$user->store;
    }
    last if $errcount >= $maxerr;
}
$checkstop = time;

warn "Checked $checkcount out of $reccount records\n";
printf STDERR "Average check time: %5.2f seconds\n",
          ($checkstop-$checkstart)/$checkcount;
for $why (sort(keys(%counts))) {
    printf STDERR "%-35.35s : $counts{$why}\n", $why;
}

sub count {
    my $why = shift;
    $counts{$why}++;
}
